home *** CD-ROM | disk | FTP | other *** search
/ Libris Britannia 4 / science library(b).zip / science library(b) / PROGRAMM / PASCAL / 1463.ZIP / DRAW-2D.ARC / PROC1.PAS < prev    next >
Pascal/Delphi Source File  |  1986-12-03  |  4KB  |  145 lines
  1. PROCEDURE CLS;
  2. (* PROCEDURE TO CLEAR ENTIRE SCREEN AND HOME CURSOR  *)
  3. (* D.J. POWERS     [010485]     *)
  4. BEGIN
  5.    HIRES;                                 (* TURBO-PASCAL PROC *)
  6.    GRAPHWINDOW(XPMIN,YPMIN,XPMAX,YPMAX);  (* TURBO-PASCAL PROC *)
  7. END;
  8. FUNCTION GENSTR(T:CHAR; N:INTEGER):SCRLINE;
  9.  VAR
  10.   K:INTEGER;
  11.   S:SCRLINE;
  12. BEGIN
  13.   S := '';
  14.   FOR K := 1 TO N DO
  15.     S := S + T;
  16.   GENSTR := S;
  17. END;
  18. FUNCTION UPCSTR(S:SCRLINE):SCRLINE;
  19.   VAR
  20.     K:INTEGER;
  21.     X:SCRLINE;
  22.   BEGIN
  23.     X := '';
  24.     FOR K := 1 TO LENGTH(S)  DO
  25.         X := X + UPCASE(COPY(S,K,1));
  26.     UPCSTR := X;
  27.   END;
  28. PROCEDURE RING(N:INTEGER);
  29. (* PROCEDURE TO RING THE TERMINAL BELL *)
  30. (* D.J. POWERS      [010485]   *)
  31. (* INPUT:  N = number of rings desired  *)
  32.  VAR
  33.   I:INTEGER;
  34.  BEGIN
  35.     IF BellCode <> 0 THEN
  36.       FOR I:=1 TO N DO
  37.          WRITE(CHR(BellCode));
  38.  END;
  39. PROCEDURE RING2;
  40.  BEGIN
  41.    WRITE(CHR(7));            (** HARDWARE DEPENDENT **)
  42.  END;
  43. PROCEDURE MOVCUR(LINE,COLUMN:INTEGER);
  44. (* PROCEDURE TO PLACE CURSOR AT SPECIFIED LINE & COLUMN *)
  45. (* D.J. POWERS     [010485]     *)
  46. BEGIN
  47.    GOTOXY(COLUMN,LINE);
  48. END;
  49. FUNCTION ASKCHAR(ROW,COL,UCASE:INTEGER; MSG:SCRLINE; MIN,MAX,DEF:CHAR):CHAR;
  50.    VAR
  51.      T:CHAR;
  52.    BEGIN
  53.      MOVCUR(ROW,1);
  54.      WRITE(BLKLINE);
  55.      MOVCUR(ROW,COL);
  56.      WRITE(MSG);
  57.      RING(1);
  58.      READ(KBD,T);
  59.      IF UCASE = 1 THEN T := UPCASE(T);
  60.      IF ORD(T) = 13 THEN T := DEF;                                (* <CR> = 13,  NO INPUT *)
  61.      IF (MIN <> MAX) AND ((T < MIN) OR (T > MAX)) THEN T := DEF;  (* OUT OF RANGE *)
  62.      ASKCHAR := T;
  63.      MOVCUR(ROW,1);
  64.      WRITE(BLKLINE);
  65.    END;
  66. FUNCTION ASKSTR(ROW,COL,UCASE:INTEGER; MSG:SCRLINE; MIN,MAX,DEF:SCRLINE):SCRLINE;
  67.    VAR
  68.      T:SCRLINE;
  69.    BEGIN
  70.      MOVCUR(ROW,1);
  71.      WRITE(BLKLINE);
  72.      MOVCUR(ROW,COL);
  73.      WRITE(MSG);
  74.      RING(1);
  75.      READ(T);
  76.      IF UCASE = 1 THEN T := UPCSTR(T);
  77.      IF LENGTH(T) = 0 THEN T := DEF        (* NO INPUT *)
  78.         ELSE
  79.           IF (MIN <> MAX) AND ((T < MIN) OR (T > MAX)) THEN T := DEF;  (* OUT OF RANGE *)
  80.      ASKSTR := T;
  81.      MOVCUR(ROW,1);
  82.      WRITE(BLKLINE);
  83.    END;
  84. FUNCTION ASKINT(ROW,COL:INTEGER; MSG:SCRLINE; MIN,MAX,DEF:INTEGER):INTEGER;
  85.    VAR
  86.      T,CODE:INTEGER;
  87.      S:FLDSTR;
  88.    BEGIN
  89.      MOVCUR(ROW,1);
  90.      WRITE(BLKLINE);
  91.      MOVCUR(ROW,COL);
  92.      WRITE(MSG);
  93.      RING(1);
  94.      READ(S);
  95.      TRIM(S);
  96.      IF LENGTH(S) = 0 THEN T := DEF          (* NO INPUT *)
  97.         ELSE
  98.          BEGIN
  99.           VAL(S,T,CODE);
  100.           IF CODE <> 0 THEN T := DEF         (* INVALID INPUT *)
  101.             ELSE                             (* OUT OF RANGE *)
  102.               IF (MIN <> MAX) AND ((T < MIN) OR (T > MAX)) THEN T := DEF;
  103.          END;
  104.      ASKINT := T;
  105.      MOVCUR(ROW,1);
  106.      WRITE(BLKLINE);
  107.    END;
  108. FUNCTION ASKREAL(ROW,COL:INTEGER; MSG:SCRLINE; MIN,MAX,DEF:REAL):REAL;
  109.    VAR
  110.      T:REAL;
  111.      CODE:INTEGER;
  112.      S:FLDSTR;
  113.    BEGIN
  114.      MOVCUR(ROW,1);
  115.      WRITE(BLKLINE);
  116.      MOVCUR(ROW,COL);
  117.      WRITE(MSG);
  118.      RING(1);
  119.      READ(S);
  120.      TRIM(S);
  121.      IF LENGTH(S) = 0 THEN T := DEF        (* NO INPUT *)
  122.         ELSE
  123.          BEGIN
  124.           VAL(S,T,CODE);
  125.           IF CODE <> 0 THEN T := DEF       (* INVALID INPUT *)
  126.             ELSE                           (* OUT OF RANGE  *)
  127.               IF (MIN <> MAX) AND ((T < MIN) OR (T > MAX)) THEN T := DEF;
  128.          END;
  129.      ASKREAL := T;
  130.      MOVCUR(ROW,1);
  131.      WRITE(BLKLINE);
  132.    END;
  133. PROCEDURE PAUSE;
  134. (* PROCEDURE TO SUSPEND PROGRAM OPERATION *)
  135. (* D.J. POWERS    [010485]   *)
  136.     CONST
  137.       MSG = 'Press any key to continue';
  138.     VAR
  139.       DUMMY:CHAR;
  140.     BEGIN
  141.       DUMMY := ASKCHAR(24,30,0,MSG,' ',' ',' ');
  142.     END;
  143.  
  144.  
  145.